{-# LANGUAGE NoMonomorphismRestriction, MultiParamTypeClasses #-}

module Evaluator2 where

import qualified Data.Map as M
import Data.Map((!))
import Control.Monad.State

data Function = I | Zero | Succ | Dbl
           | Get | Put
           | S | K | Inc | Dec
           | Attack | Help | Copy | Revive | Zombie deriving (Eq, Ord, Show, Enum, Bounded)

-- список карт
cards = [minBound .. maxBound] :: [Function]

data Field = FA Function [Field] | FI Int deriving (Ord, Eq)

instance Show Field where
    show (FI i) = show i
    show (FA f []) = show f
    show (FA f args) = "(" ++ unwords (show f : map show args) ++ ")"

app :: Field -> Field -> Either String Field
app (FA f args) newArg = Right $ FA f (args ++ [newArg])
app l r = Left $ "can't apply " ++ show l ++ " to " ++ show r

field_id = FA I []

data CellState = CS { vitality  :: Int, field :: Field}

is_zombie cs = vitality cs == -1

instance Show CellState where
	show s = "{" ++ show (vitality s) ++ ", " ++ show (field s) ++ "}"

instance Eq CellState where
	 a == b = ((vitality a) ==  (vitality b)) && ((field a) == (field b))

instance Ord CellState where
	 a <= b = ((vitality a) <=  (vitality b)) || (((field a) <= (field b)) || (vitality a) ==  (vitality b))

type SlotInd = Int

newtype PlayerState = PS {unPS :: M.Map SlotInd CellState} deriving Eq
instance Show PlayerState where
    show = show . changed_slots

changed_slots = filter (\s -> (snd s) /= init_slot) . M.toList . unPS

init_slot = CS { vitality = 10000, field = field_id}
init_player_state = PS $ M.fromList $ zip [0..255] (repeat init_slot)

data GameState = GS {proponent :: PlayerState, opponent :: PlayerState, app_counter :: Int} deriving Show

-- Меняем пользователей, нужно, так как все карты реализованы от первого лица
swap_players :: GameState -> GameState
swap_players gs = gs {proponent = opponent gs, opponent = proponent gs}

init_game_state = GS init_player_state init_player_state 0

-- Игровая монада. По сути гибрид State и Error, собранный вручную
newtype Game a = Game { ug :: (GameState -> ((Either String a), GameState)) }

instance Monad Game where
    return x = Game $ \s -> (Right x, s)
    fail e   = Game $ \s -> (Left e, s)
    Game m >>= f = Game $ \s0 -> let (x1, s1) = m s0
                                 in case x1 of
                                      Right v -> ug (f v) s1
                                      Left err -> (Left err, s1)

instance MonadState GameState Game where
    get = Game $ \s -> (Right s, s)
    put s' = Game $ \s -> (Right (), s')

liftEither :: Either String a -> Game a
liftEither x = case x of
                 Left err -> fail err
                 Right a -> return a

-- Учет длины вычисления
tick :: Game ()
tick = do
  modify $ \gs -> gs {app_counter = app_counter gs + 1}
  c <- gets app_counter
  if c > 1000 then fail "application counter exceeded 1000"
   else return ()

ticks :: Int -> Game ()
ticks n = do
  modify $ \gs -> gs {app_counter = app_counter gs + n}
  c <- gets app_counter
  if c > 1000 then fail "application counter exceeded 1000"
   else return ()

zero_app_counter = do
  modify $ \gs -> gs {app_counter = 0}

-- Левая аппликация
left_app :: GameState -> Function -> Int -> ((Either String ()), GameState)
left_app st v i = (res, st'')
 where
   (res, st') = ug (application v i app) $ move_zombies st
   st'' = zero_slot st' i res

-- Правая аппликация
right_app :: GameState -> Int -> Function -> ((Either String ()), GameState)
right_app st i v = (res, st'')
 where
   (res, st') = ug (application v i (flip app)) $ move_zombies st
   st'' = zero_slot st' i res

zero_slot st i res = case res of
                       Left _ -> snd $ ug (modify_prop i (\s -> Right s {field = field_id})) st
                       _ -> st

-- Применяет карту, третий параметр определяет, с какой стороны выполнять аппликацию
application :: Function -> SlotInd -> (Field -> Field -> Either String Field) -> Game ()
application card i f = do
  zero_app_counter
  tick
  s <- get_prop_slot i
  applicant <- liftEither $ f (FA card []) s
  res <- eval NormalM applicant
  modify_prop i (\s -> Right $ s {field = res})

move_zombies st = let
    st' = swap_players st
    movers = map (flip move_zombie) [0..255]
    st'' = foldl (\s f -> f s) st' movers
 in swap_players st''

-- Если зомби, то выполняет действие
move_zombie :: GameState -> SlotInd -> GameState
move_zombie gs i = case is_zombie ((unPS $ proponent gs) ! i) of
                        True -> gs''
                        False -> gs
 where gs' = snd $ ug (zombie_app i) gs -- ход зомби
       gs'' = snd $ ug (modify_prop i (const $ Right $ CS 0 field_id)) gs' -- обнуление зомби

-- Применяет карту по зомбячим правилам. FIXME: пока нет модификации эффектов
zombie_app :: SlotInd -> Game ()
zombie_app i = do
  zero_app_counter
  tick
  s <- get_slot i
  applicant <- liftEither $ app s (field_id)
  eval ZombieM applicant
  return ()

-- Возвращает i-тый слот пропонента, если он живой
get_prop_slot :: Int -> Game Field
get_prop_slot i = do
  prop <- gets proponent
  let slot = (unPS prop) ! i
  case (bw i 0 255, vitality slot > 0, field slot) of
    (False, _, _) -> fail $ "index " ++ show i ++ " is out of range"
    (_, False, _) -> fail $ "slot " ++ show i ++ " is dead"
    (_,_, x     ) -> return x

get_slot :: Int -> Game Field
get_slot i = do
  prop <- gets proponent
  let slot = (unPS prop) ! i
  return $ field slot

bw i a b = a <= i && i <= b

-- модификация состояния пропонента
-- Если переданная функция вернет Left, то произойдет fail в монаде
modify_prop :: Int -> (CellState -> Either String CellState) -> Game ()
modify_prop i f = do
  gs <- get
  either fail (\op -> put $ gs {proponent = PS op}) (update_map (unPS $ proponent gs) i f)

-- модификация состояния оппонента
modify_opp :: Int -> (CellState -> Either String CellState) -> Game ()
modify_opp i f = do
  gs <- get
  either fail (\op -> put $ gs {opponent = PS op}) (update_map (unPS $ opponent gs) i f)

update_map m i f = case  bw i 0 255 of
                     False -> Left "map index out of range"
                     True -> let old = m ! i
                                 new = f old
                              in case new of
                                   Right n -> Right $ M.insert i n m
                                   Left e -> Left $ app_msg "couldn't update map" e

-- Применение карт

-- режимы применения карты
data Mode = NormalM | ZombieM

eval :: Mode -> Field -> Game Field

eval _ (FI a) = return $ FI a
eval m (FA I [ss]) = eval m ss
eval _ (FA Zero []) = return $ FI 0
eval m (FA Succ [n]) = do
  n <- eval m n
  i <- test_int n ("can't apply Succ to " ++ show n)
  return $ FI $ bound16 $ i+1
eval m (FA Dbl [n]) = do
  n <- eval m n
  i <- test_int n ("can't apply Dbl to " ++ show n)
  return $ FI $ bound16 $ i*2
eval m (FA Get [n]) = do
  n <- eval m n
  i <- test_int n ("can't apply Get to " ++ show n)
  get_prop_slot i
eval _ (FA Put [x]) = return $ FA I []
eval m (FA S [f, g, x]) = do
  u <- eval m =<< liftEither (app f x)
  tick
  v <- eval m =<< liftEither (app g x)
  tick
  r <- eval m =<< liftEither (app u v)
  tick
  return r

eval m (FA K [x, y]) = do
  r <- eval m x
  tick
  return r

eval m (FA Inc [n]) = do
  n <- eval m n
  i <- test_slot_ind n $ "can't apply Inc to" ++ show n
  case m of
    NormalM -> modify_prop i (\c -> Right $ if (vitality c) > 0 then CS {vitality = bound16 $ (vitality c) + 1, field = field c} else c)
    ZombieM -> modify_prop i (\c -> Right $ if (vitality c) > 0 then CS { vitality = (vitality c) - 1, field = field c } else c)
  return $ FA I []

eval m (FA Dec [n]) = do
  n <- eval m n
  j <- test_slot_ind n $ "can't apply Dec to" ++ show n
  let i = 255 - j
  case m of
    NormalM -> modify_prop i (\c -> Right $ if (vitality c) > 0 then CS { vitality = (vitality c) - 1, field = field c } else c)
    ZombieM -> modify_prop i (\c -> Right $ if (vitality c) > 0 then CS {vitality = bound16 $ (vitality c) + 1, field = field c} else c)
  return $ FA I []

eval m (FA Attack [i, j, n]) = do
  i <- eval m i
  j <- eval m j
  n <- eval m n
  ticks 2
  i' <- test_slot_ind i $ "can't Attack from slot" ++ show i
  n' <- test_int n $ "can't Attack with non integral damage"
  modify_prop i' (\c -> if (vitality c) >= n' then Right CS { vitality = (vitality c) - n', field = field c } else Left "can't Attack, insufficient health")
  -- наносим урон
  j' <- test_slot_ind j $ "can't Attack slot" ++ show j
  case m of
    NormalM -> modify_opp (255 - j') (\c -> Right CS {vitality = bound16 $ (vitality c) - 9*n' `div` 10, field = field c })
    ZombieM -> modify_opp (255 - j') (\c -> Right $ if vitality c > 0 then CS {vitality = bound16 $ (vitality c) + 9*n' `div` 10, field = field c} else c)
  return $ FA I []

eval m (FA Help [i, j, n]) = do
  i <- eval m i
  j <- eval m j
  n <- eval m n
  ticks 2
  i' <- test_slot_ind i $ "can't Help from slot" ++ show i
  n' <- test_int n $ "can't Help with non integral amount"
  modify_prop i' (\c -> if (vitality c) >= n' then Right CS { vitality = (vitality c) - n', field = field c } else Left "can't Help, insufficient health")
  -- лечим
  j' <- test_slot_ind j $ "can't Help slot" ++ show j
  case m of
    NormalM -> modify_prop j' (\c -> Right $ if vitality c > 0 then CS { vitality = bound16 $ (vitality c) + 11*n' `div` 10, field = field c} else c)
    ZombieM -> modify_prop j' (\c -> Right $ CS { vitality = bound16 $ (vitality c) - 11*n' `div` 10, field = field c})
  return $ FA I []

eval m (FA Copy [i]) = do
  i <- eval m i
  i' <- test_slot_ind i $ "can't Copy slot" ++ show i
  prop <- gets opponent
  let slot = (unPS prop) ! i'
  return $ field slot

eval m (FA Revive [i]) = do
  i <- eval m i
  i' <- test_slot_ind i $ "can't Revive slot" ++ show i
  modify_prop i' (\c -> Right $ if (vitality c) > 0 then c else CS { vitality = 1, field = field c})
  return $ FA I []

eval m (FA Zombie [i,x]) = do
  i <- eval m i
  x <- eval m x
  tick
  i' <- test_slot_ind i $ "can't Zombie slot" ++ show i
  modify_opp (255-i') (\c -> if (vitality c) > 0 then Left "can't Zombie alive slot" else Right CS { vitality = -1, field = field c})
  return $ FA I []

-- для неполных комбинаторов
eval _ x = return x

-- Вспомогательные функции
app_msg s1 s2 = s1 ++ "; " ++ s2
-- проверка на целочисленность
test_int v e  = case v of
                  FI i -> return i
                  _ -> fail (app_msg e "not a number")

-- проверка на правильность в качестве индекса слота
test_slot_ind v e = do
  i <- test_int v e
  case bounds8 i == i of
    True -> return i
    False -> fail (app_msg e $ "not a slot number" ++ show v)

-- Обрезание по диапазонам
bound16 a | a < 0 = 0
          | a > 65535 = 65535
          | True = a

bounds8 a | a < 0 = 0
          | a > 255 = 255
          | True = a

